Sub 多条件多列汇总()
    Dim DataTable(1 To 10000, 1 To 6)
    Dim tRow%, x%, k%
    Dim aRng
    Dim sr$
    Dim index As Object
    Set index = CreateObject("Scripting.Dictionary")
    
    aRng = Range("A2:F" & Range("A65536").End(xlUp).Row)
    For x = 1 To UBound(aRng)
        sr = aRng(x, 3)
        If index.Exists(sr) Then
            tRow = index(sr)
            DataTable(tRow, 2) = DataTable(tRow, 2) + aRng(x, 6)
        Else
            k = k + 1
            index(sr) = k
            DataTable(k, 1) = aRng(x, 3)
            DataTable(k, 2) = aRng(x, 6)


        End If
    Next x

    Range("I2").Resize(k, 3) = DataTable
End Sub